Problem 23

A perfect number is a number for which the sum of its proper divisors is exactly equal to the number. For example, the sum of the proper divisors of $28$ would be $1 + 2 + 4 + 7 + 14 = 28$, which means that $28$ is a perfect number.

A number $n$ is called deficient if the sum of its proper divisors is less than $n$ and it is called abundant if this sum exceeds $n$.

As $12$ is the smallest abundant number, $1 + 2 + 3 + 4 + 6 = 16$, the smallest number that can be written as the sum of two abundant numbers is $24$. By mathematical analysis, it can be shown that all integers greater than $28123$ can be written as the sum of two abundant numbers. However, this upper limit cannot be reduced any further by analysis even though it is known that the greatest number that cannot be expressed as the sum of two abundant numbers is less than this limit.

Find the sum of all the positive integers which cannot be written as the sum of two abundant numbers.

1
2
3
4
5
6
abundant = Select[Range[28123], Total@Divisors[#] > 2 # &];
lists = Range[28123];
Dynamic[see]
(see = #; lists = Complement[lists, # + abundant]) & /@ abundant;

lists // Total

其他解答:

1
2
3
4
5
n = 28123; s = {};
a = Reap[Array[If[DivisorSigma[1, #] - # > #, Sow@#] &, n]][[2, 1]];
p = Position[a, x_ /; x > n/2, 1, 1][[1, 1]];
Do[s = Union[s, a[[i]] + Drop[a, i - 1]], {i, p}]
Tr@Complement[Range@n, s]

Problem 24

A permutation is an ordered arrangement of objects. For example, 3124 is one possible permutation of the digits $1, 2, 3$ and $4$. If all of the permutations are listed numerically or alphabetically, we call it lexicographic order. The lexicographic permutations of $0, 1$ and $2$ are:

012 021 102 120 201 210

What is the millionth lexicographic permutation of the digits $0, 1, 2, 3, 4, 5, 6, 7, 8$ and $9$?

1
2
lists = Permutations[Range[10] - 1, {10}];
lists[[1000000]] // FromDigits

Problem 25

The Fibonacci sequence is defined by the recurrence relation:

$F_n = F_{n−1} + F_{n−2}$, where $F_1 = 1$ and $F_2 = 1$.

Hence the first $12$ terms will be:

$F_1 = 1$
$F_2 = 1$
$F_3 = 2$
$F_4 = 3$
$F_5 = 5$
$F_6 = 8$
$F_7 = 13$
$F_8 = 21$
$F_9 = 34$
$F_{10} = 55$
$F_{11} = 89$
$F_{12} = 144$

The $12$th term, $F_{12}$, is the first term to contain three digits.

What is the index of the first term in the Fibonacci sequence to contain $1000$ digits?

1
2
3
n = 12;
While[Length@IntegerDigits@Fibonacci[n] < 1000, n++];
n

Problem 27

Euler discovered the remarkable quadratic formula:

It turns out that the formula will produce 40 primes for the consecutive integer values $0 \leq n \leq 39$. However, when $n=40$, $40^2+40+41=40(40+1)+41$ is divisible by $41$, and certainly when $n=41$, $41^2+41+41$ is clearly divisible by $41$.

The incredible formula $n^2-79 n+1601$ was discovered, which produces $80$ primes for the consecutive values $0 \leq n \leq 79$. The product of the coefficients, $-79$ and $1601$, is $-126479$.

Considering quadratics of the form: $n^2+a n+b$, where $|a|<1000$ and $|b| \leq 1000$ where $|n|$ is the modulus/absolute value of $n$ e.g. $|11|=11$ and $|-4|=4$

Find the product of the coefficients, $a$ and $b$, for the quadratic expression that produces the maximum number of primes for consecutive values of $n$, starting with $n=0$.

1
2
3
4
5
6
len[a_, b_] := Module[{n = 0}, While[PrimeQ[n^2 + a n + b], n++]; n];
SortBy[Flatten[
   Table[{a, b, len[a, b]}, {a, -1000, 1000, 1}, {b, -1000, 1000, 1}],
    1], Last][[-1]]
(*{-61, 971, 71}*)
-61*971
1
2
3
4
f[{a_, b_}] := (For[n = 0, PrimeQ[n^2 + a n + b], n++]; {n, a b})

Timing@Last@
  Sort[f /@ Flatten[Table[{a, b}, {a, -999, 999}, {b, -999, 999}], 1]]
1
2
3
4
5
lengthOfQuadraticPrimes[a_Integer, b_Integer] := 
  Block[{n = 0}, While[PrimeQ[n^2 + a n + b], n++]; n];

MaximalBy[Flatten[Table[{a, b}, {a, -999, 999}, {b, -1000, 1000}], 1],
  lengthOfQuadraticPrimes @@ # &]
1
2
3
4
5
6
7
8
9
First[Times @@@ 
   TakeLargestBy[
    Cases[Flatten[
      Table[Table[{a, b}, {a, sign1 Range[1, 1000 - 1]}, {b, 
         sign2 Range[1, 1000]}], {sign1, {-1, 1}}, {sign2, {-1, 1}}], 
      3], {x_, y_} /; x > 0 \[Or] y > 0], 
    Function[{a, b}, 
       NestWhile[# + 1 &, 0, PrimeQ[#1^2 + a #1 + b] &]] @@ # &, 
    1]] // Timing

Problem 28

Starting with the number 1 and moving to the right in a clockwise direction a 5 by 5 spiral is formed as follows:

It can be verified that the sum of the numbers on the diagonals is $101$. What is the sum of the numbers on the diagonals in a 1001 by 1001 spiral formed in the same way?

1
2
3
1 + 4 \!\(
\*UnderoverscriptBox[\(\[Sum]\), \(k = 1\), \(500\)]\((
\*SuperscriptBox[\((2  k + 1)\), \(2\)] - 3  k)\)\)

Problem 29

Consider all integer combinations of $a^b$ for $2 \leq a \leq 5$ and $2 \leq b \leq 5$:

If they are then placed in numerical order, with any repeats removed, we get the following sequence of $15$ distinct terms:

How many distinct terms are in the sequence generated by $a^b$ for $2 \leq a \leq 100$ and $2 \leq b \leq 100$?

1
Length@Union@Flatten@Table[a^b, {a, 2, 100}, {b, 2, 100}]

Problem 30

Surprisingly there are only three numbers that can be written as the sum of fourth powers of their digits:

As $1=1^4$ is not a sum it is not included. The sum of these numbers is $1634+8208+9474=19316$. Find the sum of all the numbers that can be written as the sum of fifth powers of their digits.

1
2
3
4
5
n = 2; res = {};
Dynamic[n]
While[n < 999999, 
  If[n == Total[IntegerDigits[n]^5], AppendTo[res, n]]; n++];
{res, Total[res]}

Problem 31

In the United Kingdom the currency is made up of pound $(£)$ and pence $(p)$. There are eight coins in general circulation:

It is possible to make $£ 2$ in the following way:

How many different ways can $£ 2$ be made using any number of coins?

1
2
3
4
5
6
count[n_, lst__] := Module[{numoflast = Floor[n/lst[[-1]]]},
   If[n == 0, 1, 
    If[Length[lst] == 1, 1, 
     Total[Table[
       count[n - k lst[[-1]], Most[lst]], {k, 0, numoflast}]]]]];
count[200, {1, 2, 5, 10, 20, 50, 100, 200}]

Problem 32

We shall say that an $n$-digit number is pandigital if it makes use of all the digits $1$ to $n$ exactly once; for example, the $5$-digit number, $15234$, is $1$ through $5$ pandigital.

The product $7254$ is unusual, as the identity, $39 \times 186=7254$, containing multiplicand, multiplier, and product is $1$ through $9$ pandigital. Find the sum of all products whose multiplicand/multiplier/product identity can be written as a $1$ through $9$ pandigital.

HINT: Some products can be obtained in more than one way so be sure to only include it once in your sum.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
alldigits = Range[9];
lst = {};
(multiplicand = #;
    If[Length[multiplicand] == 1,
     (multiplier = #; 
        If[Sort[IntegerDigits[
            FromDigits[multiplicand] FromDigits[multiplier]]] == 
          Sort[Complement[alldigits, multiplier, multiplicand]], 
         AppendTo[
          lst, {FromDigits[multiplicand], FromDigits[multiplier], 
           FromDigits[multiplicand] FromDigits[multiplier]}]]) & /@ 
      Permutations[Complement[alldigits, multiplicand], {4}],
     (multiplier = #; 
        If[Sort[IntegerDigits[
            FromDigits[multiplicand] FromDigits[multiplier]]] == 
          Sort[Complement[alldigits, multiplier, multiplicand]], 
         AppendTo[
          lst, {FromDigits[multiplicand], FromDigits[multiplier], 
           FromDigits[multiplicand] FromDigits[multiplier]}]]) & /@ 
      Permutations[Complement[alldigits, multiplicand], {3}]
     ]) & /@ Permutations[alldigits, {1, 2}];
lst[[All, 3]] // Union // Total

其它结果

1
2
3
4
5
test = MemberQ[
    Table[Union @@ IntegerDigits@#[[{i, -i}]], {i, 2, Length@#/2}] &[
     Divisors@FromDigits@#], Range@9~Complement~#] &;

FromDigits /@ Select[Range@9~Permutations~{4}, test] // Tr

Problem 33

The fraction $49 / 98$ is a curious fraction, as an inexperienced mathematician in attempting to simplify it may incorrectly believe that $49 / 98=4 / 8$, which is correct, is obtained by cancelling the $9$s.

We shall consider fractions like, $30 / 50=3 / 5$, to be trivial examples.

There are exactly four non-trivial examples of this type of fraction, less than one in value, and containing two digits in the numerator and denominator.

If the product of these four fractions is given in its lowest common terms, find the value of the denominator.

1
2
3
4
5
6
7
8
9
10
11
12
13
test[mn__] := 
  Module[{commonDigits = 
     Intersection[IntegerDigits[mn[[1]]], IntegerDigits[mn[[2]]]], 
    m = mn[[1]], n = mn[[2]]}, 
   If[Length[commonDigits] == 1 && commonDigits != {0} && 
     FromDigits[Complement[IntegerDigits[n], commonDigits]] != 0, 
    m/n == FromDigits[Complement[IntegerDigits[m], commonDigits]]/
     FromDigits[Complement[IntegerDigits[n], commonDigits]], False
    ]
   ];
res = Select[Flatten[Table[{m, n}, {m, 10, 99}, {n, m + 1, 99}], 1], 
   test];
Times @@ (#[[1]]/#[[2]] & /@ res) // Denominator

Problem 34

1
2
test[n_] := Plus @@ (Factorial[#] & /@ IntegerDigits[n]) == n;
Total[Select[Range[100000], test]] - 3 // Timing

其它解法

1
Sum[Boole[n == Tr[IntegerDigits[n]!]] n, {n, 3, 1*^5}] // Timing
1
2
3
4
Total@(Transpose@
     Select[Transpose@{MapIndexed[{Total[#1]} == #2 + 9 &, 
         Map[Factorial, #] & /@ IntegerDigits /@ Range[10, 100000]], 
        Range[10, 100000]}, #[[1]] &])[[2]] // Timing

Problem 35

The number, $197$, is called a circular prime because all rotations of the digits: $197, 971$, and $719$, are themselves prime. There are thirteen such primes below $100: 2,3,5,7,11,13,17,31,37,71,73,79$, and $97$. How many circular primes are there below one million?

1
2
3
4
5
test[num_] := 
  And @@ (PrimeQ[FromDigits[RotateLeft[IntegerDigits[num], #]]] & /@ 
     Range[Length[IntegerDigits[num]]]);
res = Select[Prime[Range[PrimePi[1000000]]], test]
Length[res]

Problem 36

The decimal number, $585=1001001001_2$ (binary), is palindromic in both bases. Find the sum of all numbers, less than one million, which are palindromic in base $10$ and base $2$. (Please note that the palindromic number, in either base, may not include leading zeros.)

1
2
3
4
5
test[n_] := (IntegerDigits[n] == 
     Reverse[IntegerDigits[n]]) && (IntegerDigits[n, 2] == 
     Reverse[IntegerDigits[n, 2]]);
res = Select[Range[1000000], test]
Total[res]